home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / RDEBUG.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  27.9 KB  |  1,106 lines
  1. /*
  2.  * rdebug.r - tracebk, get_name, xdisp, ctrace, rtrace, failtrace, strace,
  3.  *   atrace, cotrace
  4.  */
  5.  
  6. /*
  7.  * Prototypes.
  8.  */
  9. hidden int     glbcmp    Params((char *pi, char *pj));
  10. hidden int     keyref    Params((union block *bp, dptr dp));
  11. hidden novalue showline  Params((char *f, int l));
  12. hidden novalue showlevel Params((register int n));
  13. hidden novalue ttrace    Params((noargs));
  14. hidden novalue xtrace
  15.    Params((struct b_proc *bp, word nargs, dptr arg, int pline, char *pfile));
  16.  
  17. #ifdef TraceBack
  18. /*
  19.  * tracebk - print a trace of procedure calls.
  20.  */
  21. novalue tracebk(lcl_pfp, argp)
  22. struct p_frame *lcl_pfp;
  23. dptr argp;
  24.    {
  25.    struct b_proc *cproc;
  26.  
  27. #if COMPILER
  28.  
  29.    struct debug *debug;
  30.    word nparam;
  31.  
  32.    if (lcl_pfp == NULL)
  33.       return;
  34.    debug = PFDebug(*lcl_pfp);
  35.    tracebk(lcl_pfp->old_pfp, lcl_pfp->old_argp);
  36.    cproc = debug->proc;
  37.    xtrace(cproc, (word)abs(cproc->nparam), argp, debug->old_line,
  38.       debug->old_fname);
  39.  
  40. #else                    /* COMPILER */
  41.  
  42.    struct pf_marker *origpfp = pfp;
  43.    dptr arg;
  44.    inst cipc;
  45.  
  46.    /*
  47.     * Chain back through the procedure frame markers, looking for the
  48.     *  first one, while building a foward chain of pointers through
  49.     *  the expression frame pointers.
  50.     */
  51.  
  52.    for (pfp->pf_efp = NULL; pfp->pf_pfp != NULL; pfp = pfp->pf_pfp) {
  53.       (pfp->pf_pfp)->pf_efp = (struct ef_marker *)pfp;
  54.       }
  55.  
  56.    /* Now start from the base procedure frame marker, producing a listing
  57.     *  of the procedure calls up through the last one.
  58.     */
  59.  
  60.    while (pfp) {
  61.       arg = &((dptr)pfp)[-(pfp->pf_nargs) - 1];
  62.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  63.       /*
  64.        * The ipc in the procedure frame points after the "invoke n".
  65.        */
  66.       cipc = pfp->pf_ipc;
  67.       --cipc.opnd;
  68.       --cipc.op;
  69.  
  70.       xtrace(cproc, pfp->pf_nargs, &arg[0], findline(cipc.opnd),
  71.          findfile(cipc.opnd));
  72.       /*
  73.        * On the last call, show both the call and the offending expression.
  74.        */
  75.       if (pfp == origpfp) {
  76.          ttrace();
  77.          break;
  78.          }
  79.  
  80.       pfp = (struct pf_marker *)(pfp->pf_efp);
  81.       }
  82. #endif                    /* COMPILER */
  83.    }
  84.  
  85. /*
  86.  * xtrace - procedure *bp is being called with nargs arguments, the first
  87.  *  of which is at arg; produce a trace message.
  88.  */
  89. static novalue xtrace(bp, nargs, arg, pline, pfile)
  90. struct b_proc *bp;
  91. word nargs;
  92. dptr arg;
  93. int pline;
  94. char *pfile;
  95.    {
  96.  
  97.    fprintf(stderr, "   ");
  98.    if (bp == NULL)
  99.       fprintf(stderr, "????");
  100.    else {
  101.  
  102. #if COMPILER
  103.        putstr(stderr, &(bp->pname));
  104. #else                    /* COMPILER */
  105.        if (arg[0].dword == D_Proc)
  106.           putstr(stderr, &(bp->pname));
  107.        else
  108.           outimage(stderr, arg, 0);
  109.        arg++;
  110. #endif                    /* COMPILER */
  111.  
  112.        putc('(', stderr);
  113.        while (nargs--) {
  114.           outimage(stderr, arg++, 0);
  115.           if (nargs)
  116.              putc(',', stderr);
  117.           }
  118.        putc(')', stderr);
  119.        }
  120.      
  121.    if (pline != 0)
  122.       fprintf(stderr, " from line %d in %s", pline, pfile);
  123.    putc('\n', stderr);
  124.    fflush(stderr);
  125.    }
  126. #endif                     /* TraceBack */
  127. #if COMPILER
  128.  
  129. /*
  130.  * get_name -- function to get print name of variable.
  131.  */
  132. int get_name(dp1,dp0)
  133.    dptr dp1, dp0;
  134.    {
  135.    dptr dp, varptr;
  136.    tended union block *blkptr;
  137.    struct b_proc *proc;
  138.    char sbuf[100];            /* buffer; might be too small */
  139.    word i, j, k;
  140.    int t;
  141.  
  142.    type_case *dp1 of {
  143.       tvsubs: {
  144.          blkptr = BlkLoc(*dp1);
  145.          get_name(&(blkptr->tvsubs.ssvar),dp0);
  146.          sprintf(sbuf,"[%ld:%ld]",blkptr->tvsubs.sspos,
  147.             blkptr->tvsubs.sspos+blkptr->tvsubs.sslen);
  148.          k = StrLen(*dp0);
  149. #ifdef MultiRegion
  150.      Protect(strreserve(k + j), return Error);
  151. #endif                        /* MultiRegion */
  152.          Protect(StrLoc(*dp0) = alcstr(StrLoc(*dp0),k), return Error);
  153.          j = strlen(sbuf);
  154.          Protect(alcstr(sbuf,j), return Error);
  155.          StrLen(*dp0) = j + k;
  156.  
  157.          }
  158.  
  159.       tvtbl: {
  160.          t = keyref(BlkLoc(*dp1) ,dp0);
  161.          if (t == Error)
  162.             return Error;
  163.           }
  164.  
  165.       kywdint:
  166.          if (VarLoc(*dp1) == &kywd_ran) {
  167.             StrLen(*dp0) = 7;
  168.             StrLoc(*dp0) = "&random";
  169.             }
  170.          else if (VarLoc(*dp1) == &kywd_trc) {
  171.             StrLen(*dp0) = 6;
  172.             StrLoc(*dp0) = "&trace";
  173.             }
  174.          else if (VarLoc(*dp1) == &kywd_err) {
  175.             StrLen(*dp0) = 6;
  176.             StrLoc(*dp0) = "&error";
  177.             }
  178.          else
  179.             syserr("name: unknown integer keyword variable");
  180.             
  181.       kywdpos: {
  182.          StrLen(*dp0) = 4;
  183.          StrLoc(*dp0) = "&pos";
  184.          }
  185.  
  186.       kywdsubj: {
  187.          StrLen(*dp0) = 8;
  188.          StrLoc(*dp0) = "&subject";
  189.          }
  190.  
  191.       default:
  192.          if (Offset(*dp1) == 0) {
  193.             /*
  194.              * Must be a named variable.
  195.              */
  196.             dp = VarLoc(*dp1);         /* get address of variable */
  197.             proc = PFDebug(*pfp)->proc;  /* get address of procedure block */
  198.             if (globals <= dp && dp < &globals[n_globals])
  199.                *dp0 = gnames[dp - globals];         /* global */
  200.             else if (statics <= dp && dp < &statics[n_statics]) {
  201.                i = dp - statics - proc->fstatic;    /* static */
  202.                if (i < 0 || i >= proc->nstatic)
  203.                   syserr("name: unreferencable static variable");
  204.                i += abs(proc->nparam) + proc->ndynam;
  205.                *dp0 = proc->lnames[i];
  206.                }
  207.             else if (argp <= dp && dp < &argp[abs(proc->nparam)]) 
  208.                *dp0 = proc->lnames[dp - argp];          /* argument */
  209.             else if (pfp->tend.d <= dp && dp < &pfp->tend.d[proc->ndynam])
  210.                *dp0 = proc->lnames[dp - pfp->tend.d + abs(proc->nparam)];
  211.             else
  212.                syserr("name: cannot determine variable name");
  213.             }
  214.          else {
  215.             /*
  216.              * Must be an element of a structure.
  217.              */
  218.             blkptr = (union block *)VarLoc(*dp1);
  219.             varptr = (dptr)((word *)VarLoc(*dp1) + Offset(*dp1));
  220.             switch ((int)BlkType(blkptr)) {
  221.                case T_Lelem:         /* list */
  222.                   i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first] + 1;
  223.                   if (i < 1)
  224.                      i += blkptr->lelem.nslots;
  225.                   while (blkptr->lelem.listprev != NULL) {
  226.                      blkptr = blkptr->lelem.listprev;
  227.                      i += blkptr->lelem.nused;
  228.                      }
  229.                   sprintf(sbuf,"L[%ld]",i);
  230.                   i = strlen(sbuf);
  231.                   Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error);
  232.                   StrLen(*dp0) = i;
  233.                   break;
  234.                case T_Record:         /* record */
  235.                   i = varptr - blkptr->record.fields;
  236.                   proc = &blkptr->record.recdesc->proc;
  237.                   sprintf(sbuf,"%s.%s",StrLoc(proc->recname),
  238.                       StrLoc(proc->lnames[i]));
  239.                   i = strlen(sbuf);
  240.                   Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error);
  241.                   StrLen(*dp0) = i;
  242.                   break;
  243.                case T_Telem:         /* table */
  244.                   t = keyref(blkptr,dp0);
  245.                   if (t == Error)
  246.                       return Error;
  247.                   break;
  248.                default:        /* none of the above */
  249.                   syserr("name: invalid structure reference");
  250.                }
  251.            }
  252.       }
  253.    return Succeeded;
  254.    }
  255.  
  256. #begdef PTraceSetup()
  257.    struct b_proc *proc;
  258.  
  259.    --k_trace;
  260.    showline(file_name, line_num);
  261.    showlevel(k_level);
  262.    proc = PFDebug(*pfp)->proc; /* get address of procedure block */
  263.    putstr(stderr, &proc->pname);
  264. #enddef
  265.  
  266. /*
  267.  * ctrace - a procedure is being called; produce a trace message.
  268.  */
  269. novalue ctrace()
  270.    {
  271.    dptr arg;
  272.    int n;
  273.  
  274.    PTraceSetup();
  275.  
  276.    putc('(', stderr);
  277.    arg = argp;
  278.    n = abs(proc->nparam);
  279.    while (n--) {
  280.       outimage(stderr, arg++, 0);
  281.       if (n)
  282.          putc(',', stderr);
  283.       }
  284.    putc(')', stderr);
  285.    putc('\n', stderr);
  286.    fflush(stderr);
  287.    }
  288.  
  289. /*
  290.  * rtrace - a procedure is returning; produce a trace message.
  291.  */
  292.  
  293. novalue rtrace()
  294.    {
  295.    PTraceSetup();
  296.  
  297.    fprintf(stderr, " returned ");
  298.    outimage(stderr, pfp->rslt, 0);
  299.    putc('\n', stderr);
  300.    fflush(stderr);
  301.    }
  302.  
  303. /*
  304.  * failtrace - procedure named s is failing; produce a trace message.
  305.  */
  306.  
  307. novalue failtrace()
  308.    {
  309.    PTraceSetup();
  310.  
  311.    fprintf(stderr, " failed\n");
  312.    fflush(stderr);
  313.    }
  314.  
  315. /*
  316.  * strace - a procedure is suspending; produce a trace message.
  317.  */
  318.  
  319. novalue strace()
  320.    {
  321.    PTraceSetup();
  322.  
  323.    fprintf(stderr, " suspended ");
  324.    outimage(stderr, pfp->rslt, 0);
  325.    putc('\n', stderr);
  326.    fflush(stderr);
  327.    }
  328.  
  329. /*
  330.  * atrace - a procedure is being resumed; produce a trace message.
  331.  */
  332. novalue atrace()
  333.    {
  334.    PTraceSetup();
  335.  
  336.    fprintf(stderr, " resumed\n");
  337.    fflush(stderr);
  338.    }
  339. #endif                    /* COMPILER */
  340.  
  341. /*
  342.  * keyref(bp,dp) -- print name of subscripted table
  343.  */
  344. static int keyref(bp, dp)
  345.    union block *bp;
  346.    dptr dp;
  347.    {
  348.    char *s;
  349.  
  350.    if (getimage(&(bp->telem.tref),dp) == Error)
  351.       return Error;    
  352. #ifdef MultiRegion
  353.    Protect(strreserve(StrLen(*dp) + 3), return Error);
  354. #endif                    /* MultiRegion */
  355.    Protect(s = alcstr("T[",(word)2), return Error);
  356.    Protect(alcstr(StrLoc(*dp),StrLen(*dp)), return Error);
  357.    Protect(alcstr("]",(word)1), return Error);
  358.    StrLoc(*dp) = s;
  359.    StrLen(*dp) = StrLen(*dp) + 3;
  360.  
  361.    return Succeeded;
  362.    }
  363.  
  364. #ifdef Coexpr
  365. /*
  366.  * cotrace -- a co-expression context switch; produce a trace message.
  367.  */
  368. novalue cotrace(ccp, ncp, swtch_typ, valloc)
  369. struct b_coexpr *ccp;
  370. struct b_coexpr *ncp;
  371. int swtch_typ;
  372. dptr valloc;
  373.    {
  374.    struct b_proc *proc;
  375.  
  376. #if !COMPILER
  377.    inst t_ipc;
  378. #endif                    /* !COMPILER */
  379.  
  380.    --k_trace;
  381.  
  382. #if COMPILER
  383.    showline(ccp->file_name, ccp->line_num);
  384.    proc = PFDebug(*ccp->es_pfp)->proc;     /* get address of procedure block */
  385. #else                    /* COMPILER */
  386.  
  387.    /*
  388.     * Compute the ipc of the instruction causing the context switch.
  389.     */
  390.    t_ipc.op = ipc.op - 1;
  391.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  392.    proc = (struct b_proc *)BlkLoc(*argp);
  393. #endif                    /* COMPILER */
  394.  
  395.    showlevel(k_level);
  396.    putstr(stderr, &proc->pname);
  397.    fprintf(stderr,"; co-expression_%ld ", (long)ccp->id);
  398.    switch (swtch_typ) {
  399.       case A_Coact:
  400.          fprintf(stderr,": ");
  401.          outimage(stderr, valloc, 0);
  402.          fprintf(stderr," @ ");
  403.          break;
  404.       case A_Coret:
  405.          fprintf(stderr,"returned ");
  406.          outimage(stderr, valloc, 0);
  407.          fprintf(stderr," to ");
  408.          break;
  409.       case A_Cofail:
  410.          fprintf(stderr,"failed to ");
  411.          break;
  412.       }
  413.    fprintf(stderr,"co-expression_%ld\n", (long)ncp->id);
  414.    fflush(stderr);
  415.    }
  416. #endif                    /* Coexpr */
  417.  
  418. /*
  419.  * showline - print file and line number information.
  420.  */
  421. static novalue showline(f, l)
  422. char *f;
  423. int l;
  424.    {
  425.    int i;
  426.  
  427.    i = (int)strlen(f);
  428.  
  429. #if MVS
  430.    while (i > 22) {
  431. #else                    /* MVS */
  432.    while (i > 13) {
  433. #endif                    /* MVS */
  434.       f++;
  435.       i--;
  436.       }
  437.    if (l > 0)
  438.  
  439. #if MVS
  440.       fprintf(stderr, "%-22s: %4d  ",f, l);
  441.    else
  442.       fprintf(stderr, "                      :      ");
  443. #else                    /* MVS */
  444.       fprintf(stderr, "%-13s: %4d  ",f, l);
  445.    else
  446.       fprintf(stderr, "              :      ");
  447. #endif                    /* MVS */
  448.  
  449.    }
  450.  
  451. /*
  452.  * showlevel - print "| " n times.
  453.  */
  454. static novalue showlevel(n)
  455. register int n;
  456.    {
  457.    while (n-- > 0) {
  458.       putc('|', stderr);
  459.       putc(' ', stderr);
  460.       }
  461.    }
  462.  
  463. #if !COMPILER
  464.  
  465. #include "../h/opdefs.h"
  466.  
  467.  
  468. #ifdef TraceBack
  469. extern struct b_list value_tmp;        /* argument of Op_Apply */
  470. extern struct b_proc *opblks[];
  471.  
  472. extern word lastop;            /* last op-code */
  473.  
  474. extern dptr xargp;
  475. extern word xnargs;            /* number of arguments */
  476.  
  477. #endif                    /* TraceBack */
  478.  
  479.  
  480. #ifdef TraceBack
  481. /*
  482.  * ttrace - show offending expression.
  483.  */
  484. hidden novalue ttrace()
  485.    {
  486.    struct b_proc *bp;
  487.    word nargs;
  488.  
  489.    fprintf(stderr, "   ");
  490.  
  491.    switch ((int)lastop) {
  492.  
  493.       case Op_Invoke:
  494.          bp = (struct b_proc *)BlkLoc(*xargp);
  495.          nargs = xnargs;
  496.          if (xargp[0].dword == D_Proc)
  497.             putstr(stderr, &(bp->pname));
  498.          else
  499.             outimage(stderr, xargp, 0);
  500.          putc('(', stderr);
  501.          while (nargs--) {
  502.             outimage(stderr, ++xargp, 0);
  503.             if (nargs)
  504.                putc(',', stderr);
  505.             }
  506.          putc(')', stderr);
  507.          break;
  508.  
  509.       case Op_Toby:
  510.          putc('{', stderr);
  511.          outimage(stderr, ++xargp, 0);
  512.          fprintf(stderr, " to ");
  513.          outimage(stderr, ++xargp, 0);
  514.          fprintf(stderr, " by ");
  515.          outimage(stderr, ++xargp, 0);
  516.          putc('}', stderr);
  517.          break;
  518.  
  519.       case Op_Subsc:
  520.          putc('{', stderr);
  521.          outimage(stderr, ++xargp, 0);
  522.  
  523. #if EBCDIC != 1
  524.          putc('[', stderr);
  525. #else                    /* EBCDIC != 1 */
  526.          putc('$', stderr);
  527.          putc('<', stderr);
  528. #endif                    /* EBCDIC != 1 */
  529.  
  530.          outimage(stderr, ++xargp, 0);
  531.  
  532. #if EBCDIC != 1
  533.          putc(']', stderr);
  534. #else                    /* EBCDIC != 1 */
  535.          putc('$', stderr);
  536.          putc('>', stderr);
  537. #endif                    /* EBCDIC != 1 */
  538.  
  539.          putc('}', stderr);
  540.          break;
  541.  
  542.       case Op_Sect:
  543.          putc('{', stderr);
  544.          outimage(stderr, ++xargp, 0);
  545.  
  546. #if EBCDIC != 1
  547.          putc('[', stderr);
  548. #else                    /* EBCDIC != 1 */
  549.          putc('$', stderr);
  550.          putc('<', stderr);
  551. #endif                    /* EBCDIC != 1 */
  552.  
  553.          outimage(stderr, ++xargp, 0);
  554.          putc(':', stderr);
  555.          outimage(stderr, ++xargp, 0);
  556.  
  557. #if EBCDIC != 1
  558.          putc(']', stderr);
  559. #else                    /* EBCDIC != 1 */
  560.          putc('$', stderr);
  561.          putc('>', stderr);
  562. #endif                    /* EBCDIC != 1 */
  563.  
  564.          putc('}', stderr);
  565.          break;
  566.  
  567.       case Op_Bscan:
  568.          putc('{', stderr);
  569.          outimage(stderr, xargp, 0);
  570.          fputs(" ? ..}", stderr);
  571.          break;
  572.  
  573.       case Op_Coact:
  574.          putc('{', stderr);
  575.          outimage(stderr, ++xargp, 0);
  576.          fprintf(stderr, " @ ");
  577.          outimage(stderr, ++xargp, 0);
  578.          putc('}', stderr);
  579.          break;
  580.  
  581.       case Op_Apply:
  582.          outimage(stderr, xargp++, 0);
  583.          fprintf(stderr," ! ");
  584.          outimage(stderr, (dptr)&value_tmp, 0);
  585.          break;
  586.  
  587.       case Op_Create:
  588.          fprintf(stderr,"{create ..}");
  589.          break;
  590.  
  591.       case Op_Field:
  592.          putc('{', stderr);
  593.          outimage(stderr, ++xargp, 0);
  594.          fprintf(stderr, " . ");
  595.          fprintf(stderr, "%s", StrLoc(fnames[IntVal(*++xargp)]));
  596.          putc('}', stderr);
  597.          break;
  598.  
  599.       case Op_Limit:
  600.          fprintf(stderr, "limit counter: ");
  601.          outimage(stderr, xargp, 0);
  602.          break;
  603.  
  604.       case Op_Llist:
  605.  
  606. #if EBCDIC != 1
  607.          fprintf(stderr,"[ ... ]");
  608. #else                    /* EBCDIC != 1 */
  609.          fputs("$< ... $>", stderr);
  610. #endif                    /* EBCDIC != 1 */
  611.          break;
  612.  
  613.    
  614.       default:
  615.          bp = opblks[lastop];
  616.          nargs = abs((int)bp->nparam);
  617.          putc('{', stderr);
  618.          if (lastop == Op_Bang || lastop == Op_Random)
  619.             goto oneop;
  620.          if (abs((int)bp->nparam) >= 2) {
  621.             outimage(stderr, ++xargp, 0);
  622.             putc(' ', stderr);
  623.             putstr(stderr, &(bp->pname));
  624.             putc(' ', stderr);
  625.            }
  626.          else
  627. oneop:
  628.          putstr(stderr, &(bp->pname));
  629.          outimage(stderr, ++xargp, 0);
  630.          putc('}', stderr);
  631.       }
  632.      
  633.    if (ipc.opnd != NULL)
  634.       fprintf(stderr, " from line %d in %s", findline(ipc.opnd),
  635.          findfile(ipc.opnd));
  636.    putc('\n', stderr);
  637.    fflush(stderr);
  638.    }
  639.  
  640. #endif                     /* TraceBack */
  641.  
  642.  
  643.  
  644.  
  645. /*
  646.  * ctrace - procedure named s is being called with nargs arguments, the first
  647.  *  of which is at arg; produce a trace message.
  648.  */
  649. novalue ctrace(dp, nargs, arg)
  650. dptr dp;
  651. int nargs;
  652. dptr arg;
  653.    {
  654.  
  655.    showline(findfile(ipc.opnd), findline(ipc.opnd));
  656.    showlevel(k_level);
  657.    putstr(stderr, dp);
  658.    putc('(', stderr);
  659.    while (nargs--) {
  660.       outimage(stderr, arg++, 0);
  661.       if (nargs)
  662.          putc(',', stderr);
  663.       }
  664.    putc(')', stderr);
  665.    putc('\n', stderr);
  666.    fflush(stderr);
  667.    }
  668.  
  669. /*
  670.  * rtrace - procedure named s is returning *rval; produce a trace message.
  671.  */
  672.  
  673. novalue rtrace(dp, rval)
  674. dptr dp;
  675. dptr rval;
  676.    {
  677.    inst t_ipc;
  678.  
  679.    /*
  680.     * Compute the ipc of the return instruction.
  681.     */
  682.    t_ipc.op = ipc.op - 1;
  683.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  684.    showlevel(k_level);
  685.    putstr(stderr, dp);
  686.    fprintf(stderr, " returned ");
  687.    outimage(stderr, rval, 0);
  688.    putc('\n', stderr);
  689.    fflush(stderr);
  690.    }
  691.  
  692. /*
  693.  * failtrace - procedure named s is failing; produce a trace message.
  694.  */
  695.  
  696. novalue failtrace(dp)
  697. dptr dp;
  698.    {
  699.    inst t_ipc;
  700.  
  701.    /*
  702.     * Compute the ipc of the fail instruction.
  703.     */
  704.    t_ipc.op = ipc.op - 1;
  705.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  706.    showlevel(k_level);
  707.    putstr(stderr, dp);
  708.    fprintf(stderr, " failed");
  709.    putc('\n', stderr);
  710.    fflush(stderr);
  711.    }
  712.  
  713. /*
  714.  * strace - procedure named s is suspending *rval; produce a trace message.
  715.  */
  716.  
  717. novalue strace(dp, rval)
  718. dptr dp;
  719. dptr rval;
  720.    {
  721.    inst t_ipc;
  722.  
  723.    /*
  724.     * Compute the ipc of the suspend instruction.
  725.     */
  726.    t_ipc.op = ipc.op - 1;
  727.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  728.    showlevel(k_level);
  729.    putstr(stderr, dp);
  730.    fprintf(stderr, " suspended ");
  731.    outimage(stderr, rval, 0);
  732.    putc('\n', stderr);
  733.    fflush(stderr);
  734.    }
  735.  
  736. /*
  737.  * atrace - procedure named s is being resumed; produce a trace message.
  738.  */
  739.  
  740. novalue atrace(dp)
  741. dptr dp;
  742.    {
  743.    inst t_ipc;
  744.  
  745.    /*
  746.     * Compute the ipc of the instruction causing resumption.
  747.     */
  748.    t_ipc.op = ipc.op - 1;
  749.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  750.    showlevel(k_level);
  751.    putstr(stderr, dp);
  752.    fprintf(stderr, " resumed");
  753.    putc('\n', stderr);
  754.    fflush(stderr);
  755.    }
  756.  
  757. #ifdef Coexpr
  758. /*
  759.  * coacttrace -- co-expression is being activated; produce a trace message.
  760.  */
  761. novalue coacttrace(ccp, ncp)
  762. struct b_coexpr *ccp;
  763. struct b_coexpr *ncp;
  764.    {
  765.    struct b_proc *bp;
  766.    inst t_ipc;
  767.  
  768.    bp = (struct b_proc *)BlkLoc(*argp);
  769.    /*
  770.     * Compute the ipc of the activation instruction.
  771.     */
  772.    t_ipc.op = ipc.op - 1;
  773.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  774.    showlevel(k_level);
  775.    putstr(stderr, &(bp->pname));
  776.    fprintf(stderr,"; co-expression_%ld : ", (long)ccp->id);
  777.    outimage(stderr, (dptr)(sp - 3), 0);
  778.    fprintf(stderr," @ co-expression_%ld\n", (long)ncp->id);
  779.    fflush(stderr);
  780.    }
  781.  
  782. /*
  783.  * corettrace -- return from co-expression; produce a trace message.
  784.  */
  785. novalue corettrace(ccp, ncp)
  786. struct b_coexpr *ccp;
  787. struct b_coexpr *ncp;
  788.    {
  789.    struct b_proc *bp;
  790.    inst t_ipc;
  791.  
  792.    bp = (struct b_proc *)BlkLoc(*argp);
  793.    /*
  794.     * Compute the ipc of the coret instruction.
  795.     */
  796.    t_ipc.op = ipc.op - 1;
  797.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  798.    showlevel(k_level);
  799.    putstr(stderr, &(bp->pname));
  800.    fprintf(stderr,"; co-expression_%ld returned ", (long)ccp->id);
  801.    outimage(stderr, (dptr)(&ncp->es_sp[-3]), 0);
  802.    fprintf(stderr," to co-expression_%ld\n", (long)ncp->id);
  803.    fflush(stderr);
  804.    }
  805.  
  806. /*
  807.  * cofailtrace -- failure return from co-expression; produce a trace message.
  808.  */
  809. novalue cofailtrace(ccp, ncp)
  810. struct b_coexpr *ccp;
  811. struct b_coexpr *ncp;
  812.    {
  813.    struct b_proc *bp;
  814.    inst t_ipc;
  815.  
  816.    bp = (struct b_proc *)BlkLoc(*argp);
  817.    /*
  818.     * Compute the ipc of the cofail instruction.
  819.     */
  820.    t_ipc.op = ipc.op - 1;
  821.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  822.    showlevel(k_level);
  823.    putstr(stderr, &(bp->pname));
  824.    fprintf(stderr,"; co-expression_%ld failed to co-expression_%ld\n",
  825.       (long)ccp->id, (long)ncp->id);
  826.    fflush(stderr);
  827.    }
  828. #endif                    /* Coexpr */
  829. #endif                    /* !COMPILER */
  830.  
  831. /*
  832.  * Service routine to display variables in given number of
  833.  *  procedure calls to file f.
  834.  */
  835.  
  836. int xdisp(fp,dp,count,f)
  837. #if COMPILER
  838.    struct p_frame *fp;
  839. #else                    /* COMPILER */
  840.    struct pf_marker *fp;
  841. #endif                    /* COMPILER */
  842.    register dptr dp;
  843.    int count;
  844.    FILE *f;
  845.    {
  846.    register dptr np;
  847.    register int n;
  848.    struct b_proc *bp;
  849.    word nglobals, *indices;
  850.  
  851.    while (count--) {        /* go back through 'count' frames */
  852.       if (fp == NULL)
  853.          break;       /* needed because &level is wrong in coexpressions */
  854.  
  855. #if COMPILER
  856.       bp = PFDebug(*fp)->proc;    /* get address of procedure block */
  857. #else                    /* COMPILER */
  858.       bp = (struct b_proc *)BlkLoc(*dp++); /* get addr of procedure block */
  859.       /* #%#% was: no postincrement there, but *pre*increment dp below */
  860. #endif                    /* COMPILER */
  861.  
  862.       /*
  863.        * Print procedure name.
  864.        */
  865.       putstr(f, &(bp->pname));
  866.       fprintf(f, " local identifiers:\n");
  867.  
  868.       /*
  869.        * Print arguments.
  870.        */
  871.       np = bp->lnames;
  872.       for (n = abs((int)bp->nparam); n > 0; n--) {
  873.          fprintf(f, "   ");
  874.          putstr(f, np);
  875.          fprintf(f, " = ");
  876.          outimage(f, dp++, 0);
  877.          putc('\n', f);
  878.          np++;
  879.          }
  880.  
  881.       /*
  882.        * Print locals.
  883.        */
  884. #if COMPILER
  885.       dp = fp->tend.d;
  886. #else                    /* COMPILER */
  887.       dp = &fp->pf_locals[0];
  888. #endif                    /* COMPILER */
  889.       for (n = bp->ndynam; n > 0; n--) {
  890.          fprintf(f, "   ");
  891.          putstr(f, np);
  892.          fprintf(f, " = ");
  893.          outimage(f, dp++, 0);
  894.          putc('\n', f);
  895.          np++;
  896.          }
  897.  
  898.       /*
  899.        * Print statics.
  900.        */
  901.       dp = &statics[bp->fstatic];
  902.       for (n = bp->nstatic; n > 0; n--) {
  903.          fprintf(f, "   ");
  904.          putstr(f, np);
  905.          fprintf(f, " = ");
  906.          outimage(f, dp++, 0);
  907.          putc('\n', f);
  908.          np++;
  909.          }
  910.  
  911. #if COMPILER
  912.       dp = fp->old_argp;
  913.       fp = fp->old_pfp;
  914. #else                    /* COMPILER */
  915.       dp = fp->pf_argp;
  916.       fp = fp->pf_pfp;
  917. #endif                    /* COMPILER */
  918.       }
  919.  
  920.    /*
  921.     * Print globals.  Sort names in lexical order using temporary index array.
  922.     */
  923.  
  924. #if COMPILER
  925.    nglobals = n_globals;
  926. #else                    /* COMPILER */
  927.    nglobals = eglobals - globals;
  928. #endif                    /* COMPILER */
  929.  
  930.    indices = (word *)malloc((msize)nglobals * sizeof(word));
  931.    if (indices == NULL)
  932.       return Failed;
  933.    else {
  934.       for (n = 0; n < nglobals; n++)
  935.          indices[n] = n;
  936.       qsort ((char*)indices, (int)nglobals, sizeof(word), (int (*)())glbcmp);
  937.       fprintf(f, "\nglobal identifiers:\n");
  938.       for (n = 0; n < nglobals; n++) {
  939.          fprintf(f, "   ");
  940.          putstr(f, &gnames[indices[n]]);
  941.          fprintf(f, " = ");
  942.          outimage(f, &globals[indices[n]], 0);
  943.          putc('\n', f);
  944.          }
  945.       fflush(f);
  946.       free((pointer)indices);
  947.       }
  948.    return Succeeded;
  949.    }
  950.  
  951. /*
  952.  * glbcmp - compare the names of two globals using their temporary indices.
  953.  */
  954. static int glbcmp (pi, pj)
  955. char *pi, *pj;
  956.    {
  957.    register word i = *(word *)pi;
  958.    register word j = *(word *)pj;
  959.    return lexcmp(&gnames[i], &gnames[j]);
  960.    }
  961.  
  962. #if !COMPILER
  963. int get_name(dp1,dp0)
  964.    dptr dp1, dp0;
  965.    {
  966.    dptr dp, varptr;
  967.    union block *blkptr;
  968.    char sbuf[100];            /* buffer; might be too small */
  969.    word j, k;
  970.    int i, t;
  971.  
  972.    extern word *ftabp, *records;
  973.  
  974.    type_case *dp1 of {
  975.       tvsubs: {
  976.          blkptr = BlkLoc(*dp1);
  977.          get_name(&(blkptr->tvsubs.ssvar),dp0);
  978.          sprintf(sbuf,"[%ld:%ld]",blkptr->tvsubs.sspos,
  979.             blkptr->tvsubs.sspos+blkptr->tvsubs.sslen);
  980.          k = StrLen(*dp0);
  981. #ifdef MultiRegion
  982.          Protect(strreserve(k + j), return Error);
  983. #endif                    /* MultiRegion */
  984.          Protect(StrLoc(*dp0) = alcstr(StrLoc(*dp0),k), return Error);
  985.          j = strlen(sbuf);
  986.          Protect(alcstr(sbuf,j), return Error);
  987.          StrLen(*dp0) = j + k;
  988.  
  989.          }
  990.  
  991.       tvtbl: {
  992.          t = keyref(BlkLoc(*dp1) ,dp0);
  993.          if (t == Error)
  994.             return Error;
  995.           }
  996.  
  997.       kywdint:
  998.          if (VarLoc(*dp1) == &kywd_ran) {
  999.             StrLen(*dp0) = 7;
  1000.             StrLoc(*dp0) = "&random";
  1001.             }
  1002.          else if (VarLoc(*dp1) == &kywd_trc) {
  1003.             StrLen(*dp0) = 6;
  1004.             StrLoc(*dp0) = "&trace";
  1005.             }
  1006.          else if (VarLoc(*dp1) == &kywd_err) {
  1007.             StrLen(*dp0) = 6;
  1008.             StrLoc(*dp0) = "&error";
  1009.             }
  1010.          else
  1011.             syserr("name: unknown integer keyword variable");
  1012.             
  1013.       kywdpos: {
  1014.          StrLen(*dp0) = 4;
  1015.          StrLoc(*dp0) = "&pos";
  1016.          }
  1017.  
  1018.       kywdsubj: {
  1019.          StrLen(*dp0) = 8;
  1020.          StrLoc(*dp0) = "&subject";
  1021.          }
  1022.  
  1023.       default: {
  1024.          dp = VarLoc(*dp1);        /* get address of variable */
  1025.          if (InRange(globals,dp,eglobals)) {
  1026.             *dp0 = gnames[dp - globals];         /* global */
  1027.             return Succeeded;
  1028.             }
  1029.          else if (InRange(statics,dp,estatics)) {
  1030.             blkptr = BlkLoc(*argp);
  1031.             i = dp - statics - blkptr->proc.fstatic;    /* static */
  1032.             if (i < 0 || i >= blkptr->proc.nstatic)
  1033.                syserr("name: unreferencable static variable");
  1034.             i += abs((int)blkptr->proc.nparam) + abs((int)blkptr->proc.ndynam);
  1035.             *dp0 = blkptr->proc.lnames[i];
  1036.             return Succeeded;
  1037.             }
  1038.          else if ((uword)stack < (uword)(word *)dp &
  1039.            (uword)(word *)dp <= (uword)sp) {
  1040.             if ((struct pf_marker*)dp < pfp) {    /* argument */
  1041.                *dp0 = ((struct b_proc *)VarLoc(*argp))->lnames[(dp - argp) - 1];
  1042.                }
  1043.             else {                    /* local */
  1044.                *dp0 = ((struct b_proc *)VarLoc(*argp))->lnames[dp -
  1045.                   pfp->pf_locals + ((struct b_proc *)VarLoc(*argp))->nparam];
  1046.                }
  1047.             return Succeeded;
  1048.             }
  1049.       
  1050.          /*
  1051.           * Must be an element of a structure.
  1052.           */
  1053.          blkptr = (union block *)VarLoc(*dp1);
  1054.          varptr = (dptr)((word *)VarLoc(*dp1) + Offset(*dp1));
  1055.          switch ((int)BlkType(blkptr)) {
  1056.             case T_Lelem: {        /* list */
  1057.                if ((i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first]
  1058.                   + 1) < 1)
  1059.                      i += blkptr->lelem.nslots;
  1060.                while (blkptr->lelem.listprev != NULL) {
  1061.                   blkptr = blkptr->lelem.listprev;
  1062.                   i += blkptr->lelem.nused;
  1063.                   }
  1064.                sprintf(sbuf,"L[%d]",i);
  1065.                i = strlen(sbuf);
  1066.                Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error);
  1067.                StrLen(*dp0) = i;
  1068.                break;
  1069.                }
  1070.             case T_Record: {        /* record */
  1071.                i = varptr - blkptr->record.fields;
  1072.       
  1073.       #ifdef FieldNames
  1074.            sprintf(sbuf, "%s.%s", StrLoc(blkptr->record.recdesc->proc.recname),
  1075.                StrLoc(blkptr->record.recdesc->proc.lnames[i]));
  1076.       #else                    /* FieldNames */
  1077.                j = blkptr->record.recdesc->proc.recnum - 1;
  1078.                k = 0;
  1079.                while (ftabp[j] != i) {
  1080.                   j += *records;
  1081.                   k++;
  1082.                   }
  1083.                sprintf(sbuf,"%s.%s",StrLoc(blkptr->record.recdesc-> proc.recname),
  1084.                   StrLoc(fnames[k]));
  1085.       #endif                    /* FieldNames */
  1086.       
  1087.                i = strlen(sbuf);
  1088.                Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error);
  1089.                StrLen(*dp0) = i;
  1090.                break;
  1091.                }
  1092.             case T_Telem:         /* table */
  1093.                t = keyref(blkptr,dp0);
  1094.                if (t == Error)
  1095.                    return Error;
  1096.                break;
  1097.             default:        /* none of the above */
  1098.                syserr("name: invalid structure reference");
  1099.             }
  1100.          }
  1101.       }
  1102.    return Succeeded;
  1103.    }
  1104.  
  1105. #endif                    /* !COMPILER */
  1106.